perm filename T2.F4[M11,LCS]2 blob sn#396925 filedate 1978-11-22 generic text, type T, neo UTF8
00100	C THIS ROUTINE FINDS KEY WORDS IN I ARRAY AND PUTS THEIR KEY NUMS
00200	C INTO THE IX ARRAY.  IX ARRAY ADVANCES 2 WORDS AT A TIME.
00300	C IF 2ND WRD OF EACH PAIR IS NON-ZERO THEN 1ST IS FLT. PT. NUM.
00400	C KCNT IS WORD COUNT OF INPUT STRING.
00500	        SUBROUTINE MPACK(KCNT, I,IX,IPTR)
00600		COMMON/IGEN/IGEN
00700		COMMON /TR/Q(80),QX(100),IIX(100),LX(12),INST(27,5),MX5(40)
00800		DIMENSION I(1)
00900		DATA IPP/'P'/,IFF/'F'/,IBB/'B'/,IAA/'A'/,IOO/'O'/,IRR/'R'/,
01000		1 IEE/'E'/,ISS/'S'/,IMM/'M'/,III/'I'/,ILL/'L'/,ITT/'T'/,
01100		1 IDD/'D'/,I2/'2'/,I3/'3'/,I4/'4'/,IUU/'U'/,ICC/'C'/,IHH/'H'/
01200		1,IVV/'V'/,IYY/'Y'/,IWW/'W'/,I0/'0'/,I9/'9'/,INN/'N'/,IQQ/'Q'/
01300		1,IPP/'P'/,IGG/'G'/
01400		IX=I(1)
01500		DO 100 K=1,12
01600		IF(IX.NE.LX(K))GO TO 100
01700	C LOOK FOR PUNCTUATION, ARITHMETIC OPERATORS, ETC.
01800		RETURN
01900	100	CONTINUE
02000	101	N=I(2)
02100		L=I(3)
02200		IF(IGEN.NE.2)GO TO 1000
02300	C IGEN=2=READING INSTRUMENT DEFINITION
02400	CODE NUMS ARE 1-13 FOR UNIT GENS., 100+ FOR B, 200+ FOR P, 300+ FOR F.
02500	C ORD. OF UNIT GENS:OUT,OSC,AD2,RAN,ENV,STR,AD3,AD4,MLT,SET,RAH,END,INS
02600		IF(IX.EQ.IPP)GO TO 14
02700		IF(IX.EQ.IFF)GO TO 15
02800		IF(IX.EQ.IBB)GO TO 16
02900		IF(IX.EQ.IAA)GO TO 1
03000		IF(IX.EQ.IOO)GO TO 2
03100		IF(IX.EQ.IRR)GO TO 3
03200		IF(IX.EQ.IEE)GO TO 4
03300		IF(IX.EQ.ISS)GO TO 5
03400		IF(IX.EQ.IMM)GO TO 17   
03500		IF(IX.EQ.III)GO TO 33
03600	C IF NOT A KNOWN WORD THEN ERROR
03700	999	CALL ERR(5)
03800	C NEXT FOR 'MLT'
03900	17	IF(N.NE.ILL)GO TO 999
04000		IF(L.NE.ITT)GO TO 999
04100		IX=9
04200		RETURN
04300	1	IF(N.NE.IDD)GO TO 999
04400		IF(L.EQ.I2)GO TO 6
04500	C 'AD2, AD3, AD4'
04600		IF(L.EQ.I3)GO TO 7
04700		IF(L.NE.I4)GO TO 999
04800		IX=8
04900		RETURN
05000	6	IX=3
05100		RETURN
05200	7	IX=7
05300		RETURN
05400	2	IF(N.EQ.ISS)GO TO 10
05500		IF(N.NE.IUU)GO TO 200
05600		IF(L.NE.ITT)GO TO 999
05700	C 'OUT'
05800		IX=1
05900		RETURN
06000	200	IF(N.NE.IPP)GO TO 999
06100		IF(L.NE.ITT)GO TO 999
06200	C 'OPT'  OPTIONAL USER-ADDED UNIT GENERATOR   CODE=14 IN MSCAN.
06300		IX=14
06400		RETURN
06500	10	IF(L.NE.ICC)GO TO 999
06600	C 'OSC'
06700		IX=2
06800		RETURN
06900	3	IF(N.NE.IAA)GO TO 999
07000		IF(L.EQ.INN)GO TO 11
07100		IF(L.NE.IHH)GO TO 999
07200	C 'RAN', 'RAH'
07300		IX=11
07400		RETURN
07500	11	IX=4
07600		RETURN
07700	4	IF(N.NE.INN)GO TO 999
07800		IF(L.EQ.IVV)GO TO 12
07900	C ENV, END
08000		IF(L.NE.IDD)GO TO 999
08100		IX=12
08200		RETURN
08300	12	IX=5
08400		RETURN
08500	5	IF(N.EQ.ITT)GO TO 13
08600		IF(N.NE.IEE)GO TO 999
08700	C SET, STR
08800		IF(L.NE.ITT)GO TO 999
08900		IX=10
09000		RETURN
09100	13	IF(L.NE.IRR)GO TO 999
09200		IX=6
09300		RETURN
09400	14	J=200
09500	C PN
09600	18	IF(N.LT.I0.OR.N.GT.I9)GO TO 999
09700		K2=0
09800		K1=NASCI(N)
09900	CXX	K1=N-8240
10000	C  CONVERTS ASCII CHAR. TO INTEGER ('0'=8240)
10100		IF(KCNT.EQ.2)GO TO 19
10200	C ARE THERE 2 DIGITS AFTER P, F OR B?
10300		IF(L.LT.I0.OR.L.GT.I9)GO TO 999
10400		K1=K1*10
10500	CXX	K2=L-8240
10600		K2=NASCI(L)
10700	19	IX=J+K1+K2
10800		RETURN
10900	15	J=300
11000	C  FN
11100		GO TO 18
11200	16	J=100
11300	C BN
11400		GO TO 18
11500	
11600	C NEXT FOR OTHER (MUS10 TYPE) KEY WORDS.
11700	1000	IF(KCNT.LE.3)GO TO 2000
11800	C JUMP TO FIND NOTE NAMES, PARAMS, FUNCTS.
11900		LN=I(4)
12000		IF(IX.EQ.IPP)GO TO 20
12100	C THIS LIST BEGINS WITH CODE NUM. 400:
12200	C PLAY,FINI,SRATE,NCHNS,PRINT,CHA,POWER,SRT,GEN,DUR,FREQ,INSTRU,UNIT GEN.
12300		IF(IX.EQ.IFF)GO TO 21
12400		IF(IX.EQ.ISS)GO TO 22
12500		IF(IX.EQ.INN)GO TO 23
12600		IF(IX.EQ.III)GO TO 27
12700		IF(IX.NE.IUU)GO TO 28
12800	C JUMP IF NOT ONE OF THE SPECIAL WORDS. IT MAY BE AN INSTR.
12900	C****** INSTRS CANNOT HAVE SAME NAME(1ST 4 LTRS) AS ANY OF THESE WORDS*******
13000		IF(N.NE.INN)GO TO 28
13100		IF(L.NE.III)GO TO 28
13200		IF(LN.NE.ITT)GO TO 28
13300	C UNIT GEN (FOR SPECIAL DEFINITIONS)
13400		IX=413
13500		RETURN
13600	20	IF(N.NE.ILL)GO TO 30
13700		IF(L.NE.IAA)GO TO 28
13800		IF(LN.NE.IYY)GO TO 28
13900	C PLAY
14000		IX=400
14100		RETURN
14200	30	IF(N.NE.IRR)GO TO 31
14300		IF(L.NE.III)GO TO 28
14400		IF(LN.NE.INN)GO TO 28
14500	C PRINT
14600		IX=404
14700		RETURN
14800	31	IF(N.NE.IOO)GO TO 28
14900		IF(L.NE.IWW)GO TO 28
15000		IF(LN.NE.IEE)GO TO 28
15100	C POWER(X,Y)
15200		IX=406
15300		RETURN
15400	21	IF(N.NE.III)GO TO 32
15500		IF(L.NE.INN)GO TO 28
15600		IF(LN.NE.III)GO TO 28
15700	C UNIT GEN (FOR SPECIAL DEFINITIONS)
15800		IX=401
15900		RETURN
16000	22	IF(N.NE.IRR)GO TO 28
16100		IF(L.EQ.ITT.AND.KCNT.EQ.3)GO TO 222
16200		IF(L.NE.IAA)GO TO 29
16300		IF(LN.NE.ITT)GO TO 28
16400	C SRATE, SRT
16500	222	IX=402
16600		RETURN
16700	29	IF(L.NE.ITT)GO TO 28
16800		IX=407
16900		RETURN
17000	23	IF(N.NE.ICC)GO TO 28
17100		IF(L.NE.IHH)GO TO 28
17200		IF(LN.NE.INN)GO TO 28
17300	C NCHNS
17400		IX=403
17500		RETURN
17600	24	IF(N.NE.IHH)GO TO 28
17700		IF(L.NE.IAA)GO TO 28
17800	C CHA 
17900		IX=405
18000		RETURN
18100	25	IF(N.NE.IEE)GO TO 28
18200		IF(L.NE.INN)GO TO 28
18300	C  GEN 
18400		IX=409
18500		RETURN
18600	26	IF(N.NE.IUU)GO TO 28
18700		IF(L.NE.IRR)GO TO 28
18800	C DUR
18900		IX=410
19000		RETURN
19100	27	IF(N.NE.INN)GO TO 28
19200		IF(L.NE.ISS)GO TO 28
19300		IF(KCNT.EQ.3)GO TO 33
19400		IF(LN.NE.ITT)GO TO 28
19500		IF(I(5).NE.IRR)GO TO 28
19600		IF(I(6).NE.IUU)GO TO 28
19700	C INSTRUMENT
19800		IX=412
19900		RETURN
20000	33	IX=13
20100	C 'INS'
20200		RETURN
20300	32	IF(N.NE.IRR)GO TO 28
20400		IF(L.NE.IEE)GO TO 28
20500		IF(LN.NE.IQQ)GO TO 28
20600	C FREQ
20700		IX=411
20800		RETURN
20900	28	IX=-IPTR
21000	C SEND BACK NEG. POINTER TO I ARRAY SO IT WILL LOOK FOR INST. NAME.
21100		RETURN
21200	
21300	2000	IF(IX.EQ.IPP)GO TO 14
21400	C FINDS (P1, P21, ETC.)
21500		IF(IX.EQ.ISS)GO TO 22
21600	C 'SRT'
21700		IF(IX.NE.IFF)GO TO 34
21800	C A FUNC??
21900		IF(N.GE.I0.AND.N.LE.I9)GO TO 15
22000		IF(KCNT.EQ.3)GO TO 28
22100		IX=510
22200		GO TO 36
22300	34	IF(IX.NE.ICC)GO TO 35
22400		IF(KCNT.EQ.3)GO TO 24
22500	C JUMP IF NOT A NOTE
22600		IX=501
22700	C AT THIS POINT NOTE NUMBERS RUN FROM 500 TO 520  (CF TO BS)
22800		GO TO 36
22900	35	IF(IX.NE.IGG)GO TO 38
23000	C NOW A 'GEN' OR A NOTE
23100		IF(KCNT.EQ.3)GO TO 25
23200		IX=513
23300	C THE NOTE 'G'
23400	36	IF(KCNT.EQ.1)RETURN
23500		IF(N.EQ.IFF)GO TO 39
23600		IF(N.NE.ISS) GO TO 28
23700	C NOW IT'S NOT A NOTE
23800	40	IX=IX+1
23900	C SHARP
24000		RETURN
24100	39	IX=IX-1
24200	C FLAT
24300		RETURN
24400	38	IF(IX.NE.IDD)GO TO 41
24500		IF(KCNT.EQ.3)GO TO 26
24600	C GO LOOK FOR 'DUR'
24700		IX=504
24800		GO TO 36
24900	41	IF(IX.EQ.III)GO TO 27
25000	C CATCHES  'INS'
25100		IF(IX.NE.IEE)GO TO 42
25200		IF(KCNT.EQ.3)GO TO 4
25300	C 'END' OR NOTE 'E'?
25400		IX=507
25500		GO TO 36
25600	42	IF(KCNT.EQ.3)GO TO 28
25700		IF(IX.NE.IAA)GO TO 43
25800		IX=516
25900		GO TO 36
26000	43	IF(IX.NE.IBB)GO TO 28
26100		IX=519
26200		GO TO 36
26300	
26400		END
26500	
26600	      SUBROUTINE ERR(N)
26700	      GO TO (1,2,3,4,5)N
26800	1      TYPE 101
26900	      STOP
27000	101      FORMAT(' MISSING SEMICOLON')
27100	2      TYPE 102
27200	      STOP
27300	102      FORMAT(' MISSING PARENTHESIS')
27400	3      TYPE 103
27500	      STOP
27600	103      FORMAT(' MISSING COMMA')
27700	4      TYPE 104
27800	104      FORMAT(' MISSING PLAY;')
27900	5	TYPE 105
28000	105	FORMAT(' UNKNOWN WORD')
28100	      STOP
28200	      END
28300	
28400	      SUBROUTINE ARITH(Y,W,LL)
28500	      DIMENSION W(1)
28600	      COMMON /AR/IOP
28700	47      X=W(LL-1)
28800	      GO TO (41,42,43,44),IOP
28900	41      X=X*Y
29000	      GO TO 45
29100	42      X=X/Y
29200	      GO TO 45
29300	43      X=X-Y
29400	      GO TO 45
29500	44      X=X+Y
29600	45      W(LL-1)=X
29700	      END